perm filename SC2A.FOR[M11,LCS] blob
sn#439864 filedate 1979-05-08 generic text, type T, neo UTF8
SUBROUTINE READIT
INTEGER*4 IV
COMMON /DEVS/ID1,ID21,JTYPE,ID23,ID20
COMMON /Q/ BNW(200),NWZ /INS/RINST(27),BG(60) /TYP/JOUT,LN,KTYPE
1 /ITYP/ITYP,JED /JPREC/JPREC
COMMON/VV/LIMIT,V(1) /A/NP(27),XT(27),FRM(80),INVIS(27)
1 /ALPH/IALPH(14),ISCA(12),IDAT(11)
COMMON /PCIP/ PCH(3,30)
C LIMIT OF 30 TEMPO CHNGES IN 'INTERNAL' TEMPO FEATURE.
DIMENSION IV(1),LIST(78),JNP(80),KNP(15)
C WITH VX,IOUT AT 70 AND FRM AT 80 OK FOR ONLY
C 40 LIT CHARS + 90 PARAMS PER INST.
C 60 BG TIMES AVAILABLE. FOR INSTS AND INSERTS AND EDITS.
COMMON J,L /DUR/DUR(27) /NUMP/NUMP /INP/INP(1)
1/E/IQ(27),KL,X,ZPAR,KA,INSNUM,NNUM,JJ,JA,ISUB,NFLG
1 ,VX(70),IAMP,K,KN,M,ML,CODE
COMMON/B/MOT,PR,T5,NINS,I,RA,KZY,NWX,INONLY,MX,
1 Y,Z,FNAME,MZ,N,IDALL,JC,JG,RB,IJ,IX,BW,NL,RC,W,
1 ZZ,CHN,YY
1 /D/TF,AMPFAC,OP1,DURX,IXIN,FLNM
1 /INTC/LPAR,IPRN,IRETRO,INVRT,ICON,LCNT,
1 JZ,MLX,IZ,JD,LEND,ITMP,LP,ILIT,NLIT,KTMP,IC,IA
1 /REALC/QX,PARENS,BY,ALL,QTS,RAX,RD,T4
1 /BLA/IBLA,KSLA,ISEMI,MINUS,ISTAR,ICOMM,ICOL,IQUES,ILESS,IQT
EQUIVALENCE (VX1,VX(1)),(KNP,JNP,INP1,INP),(IPP,ISCA(2))
1 ,(ISS,ISCA(9)),(ITT,ISCA(11)),(IUU,IALPH(10)),(IMM,IALPH(6))
1 ,(IFF,ISCA(6)),(IAA,ISCA(10)),(ILL,IALPH(5)),(IRR,IALPH(9))
1 ,(VX2,VX(2)),(VX3,VX(3)),(VX4,VX(4)),(IDOT,IDAT(11))
1 ,(LIST,FRM(3)),(IGG,ISCA(8)),(IEE,ISCA(5)),(IDD,ISCA(3))
1,(ITT,ISCA(11)),(III,IALPH(2)),(IYY,IALPH(14)),(INN,IALPH(7))
1,(IOO,ISCA(4)),(IQQ,IALPH(8)),(ICC,ISCA),(IXX,IALPH(13)),
1 (IHH,IALPH(1)),(ILL,IALPH(5)),(IV,V),(IZERO,IDAT(1)),
1 (NINE,IDAT(10))
C IAA=A IDD=D IEE=E IFF=F INN=N IPP=P ISS=S ITT=T
DATA RUN/'RUN'/,PREC/'PREC'/,PLAY/'PLAY'/,SECT/'SECT'/,END/'END'/,
1 FINI/'FINI'/,ISHRP/'#'/,IEXPL/'!'/,IDOL/'$'/,TMPO/'TEMP'/
1,STAR/'*'/,IPERC/'%'/,IANPR/'&'/,LPRN/'('/,IRPRN/')'/,IAT/'@'/
1,ID21/21/
C *************** READS INPUT ***********************
CC8001 FORMAT(A5,5F)
107 FORMAT(I,A5,5F)
1303 FORMAT(80A1)
142 FORMAT(I,15A5)
1301 FORMAT(15A5)
1302 FORMAT(1X15A5)
CC300 FORMAT(I,3F,A1)
301 FORMAT(3F,A1)
3311 FORMAT(' RETYPE LINE?'/)
3310 FORMAT(' TYPE A LINE'/)
3309 FORMAT(' TYPE INST NAME, ETC'/)
C8732 FORMAT(A4,80A1)
C8734 FORMAT(1X,A4,80A1)
KIMIT=LIMIT-100
C FOR WARNING ABOUT BUFFER OVERLOAD (LABEL 1774)
ICHD=0
JPREC=0
LN=0
C ** LN IS COUNTER FOR LINES READ IN. FOR ERROR MESS.
100 IOFSET=0
C IOFSET MUST BE RESET AFTER EVERY 'END'
2308 IF(ITYP.LT.0)GO TO 2127
2309 WRITE(JTYPE,3309)
READ(JTYPE,1303)JNP
WRITE(ID20,1303)JNP
GO TO 4271
2127 IF(READER(JNP).LT.0)CALL RUNIT
C READS A LINE. IF END OF FILE, JUMPS.
LN=LN+1
C ABOVE FOR COMMENTS DOESN'T CATCH THIS WITH SOS FILES⊗⊗⊗⊗⊗⊗⊗⊗⊗⊗⊗⊗
427 IF(JED.LT.0)GO TO 4271
IF(K.EQ.IYY)GO TO 4271
C K CHECK IS TO PASS AFTER RETYPING
WRITE(JTYPE,3311)
READ(JTYPE,1303)K
IF(K.EQ.IYY)GO TO 2309
IF(K.EQ.IGG)JED=-1
4271 CALL PACKER(RNAM,JNP)
IF(RNAM.EQ.RUN)CALL RUNIT
C WITH 2-PART SCORE PROGRAM, RUNIT WRITES INTO DSK FILE WHICH IS LATER READ BY
C 'RUNIT' (2ND PART OF SCORE). WITH 1-PART PROG. IT GOES STRAIGHT TO 'RUNIT'.
IF(RNAM.EQ.PREC)GO TO 6
211 CALL CLEAN(LEND)
CC MLX=1
DO 311 MLX=1,72
IZ=INP(MLX)
311 IF(IZ.EQ.IBLA.OR.IZ.EQ.ISEMI.OR.IZ.EQ.KSLA)GO TO 411
C SO SCANNER WILL SKIP INST. NAME.
411 IZ=0
JA=-1
ISUB=4
ALL=1.
VX1=0
VX2=0
VX3=0
111 INSNUM=-1
K=0
IF(V(I-1).NE.-9900.-BY)GO TO 6773
CCC IF(V(I-1).NE.-9900.-BY)GO TO 364
BY=-1.
I=I-1
6773 K=K+1
IF(K.GT.NINS)GO TO 36
IF(RINST(K).NE.RNAM)GO TO 6773
INSNUM=K
GO TO 1773
36 IF(RNAM.EQ.RUN)CALL RUNIT
297 IF(ISUB.GT.4)GO TO 1773
IF(RNAM.EQ.TMPO)GO TO 1773
362 INSNUM=NINS+1
IF(INSNUM.GT.KZY)CALL ERR(7)
RINST(INSNUM)=RNAM
IZ=INSNUM
GO TO 1773
4 IF(INSNUM.LE.NINS)GO TO 8773
IF(ALL.GT.0)GO TO 1004
IF(IDALL.GT.0)GO TO 8773
BG(INSNUM)=VX1
IDALL=INSNUM
GO TO 2004
C 'MOVE' CHANGES IN 'ALINS' CAN'T BE RESET IN INDIV. INSTS.
1004 BG(INSNUM)=VX1
IF(INSNUM.EQ.IZ)VX1=0
C MAY 3,71 **** ALL PARAMS WILL BE SET UP AT TIME 0.
C CHECK EFFECT ON 'MOVE'!
C ******** APR.23, 1971 FIXES BG TIMES IN 'MOVE'?????!!!!!!!
2004 NINS=INSNUM
IF(VX3.NE.0)VX2=10000.+VX3
IF(VX2.EQ.0)VX2=-1
DUR(INSNUM)=VX2
GO TO 900
C******** ABOVE FOR REST ONLY ENTRIES. FEB 18,71
8773 IF(VX2.EQ.0)GO TO 900
C 2 NUMBS HERE MEAN START ON NOTE NUM.VX2 OF INST.VX1
IF(VX1.EQ.0)VX1=INSNUM
C VX1=0 MEANS USE NUMB. OF THIS INST.
VX1=VX1*10000.+VX2
900 IF(VX1.EQ.BY)GO TO 3173
497 BY=VX1
C BY=CURRENT BG TIME.
V(I)=-9900.-BY
I=I+1
IF(NWZ.NE.0)CALL BGSORT(BY)
3173 IF(RNAM.EQ.TMPO)GO TO 1106
4773 NW=LPAR
ML=MLX
IF(I.LT.KIMIT)GO TO 774
WRITE(JTYPE,107)I
IF(I.GE.LIMIT)WRITE(JTYPE,1774)
1774 FORMAT(/' ******* TOO MUCH INPUT DATA!! USE "MIXSCR" *******'/)
774 ALL=1.
SUB=0
ISUB=1
1299 IF(MLX.LE.LEND)GO TO 1773
7773 IF(READER(JNP).LT.0)CALL RUNIT
C READS A LINE. IF END OF FILE, JUMPS.
IF(JED.LT.0)GO TO 77733
WRITE(JTYPE,3311)
READ(JTYPE,1303)K
CKL READ(JTYPE,77732)K
CKL CALL LO2UP(K)
IF(K.NE.IYY)GO TO 442
WRITE(JTYPE,3310)
READ(JTYPE,1303)JNP
CKL READ(JTYPE,77732)JNP
442 IF(K.EQ.IGG)JED=-1
C DOESN'T WORK FOR EDITS AND INSERTS YET???
77733 MLX=1
C FOR CONTINUATION LINES.(CAN'T 'CONTINUE' TWICE IN A ROW!!)
C 'LISTS' MUST END WITH ; IN NEW(7/74) VERSION.
CALL CLEAN(LEND)
1773 IF(IPRN.EQ.0)GO TO 17732
L=I-1
IF(QTS.GE.0)GO TO 597
IF(V(I-1).EQ.999.)L=L-1
597 IPRN=IPRN-1
IF(PARENS.EQ.0)GO TO 17733
PARENS=0
LIST(LCNT+2)=L
LCNT=LCNT+3
IF(IPRN.EQ.0)GO TO 17732
IPRN=0
17733 LIST(MOT)=L
MOT=0
C FOR ERROR TRAP
17732 N=0
17731 ML=MLX
C BIG LOOP -- TO END OF PAGE 1.
JPP=-1
C FOR OLD 'DF' STUFF. CHECKS FOR A Pn
JD=ML
975 N=INP(JD)
IF(N.EQ.IBLA)GO TO 236
IF(N.EQ.IPP)JPP=0
C FOUND 'P'
C ((((())))) MAY 13,71 /Z (D4/E/X 2 3)/ CS/ ETC. CAN USE 26 LABELS.
33611 IF(N.EQ.LPRN)GO TO 697
IF(N.NE.IRPRN)GO TO 2361
697 INP(JD)=IBLA
L=JD-1
5113 IF(INP(L).NE.IBLA)GO TO 2113
L=L-1
GO TO 5113
2113 IF(N.EQ.IRPRN)GO TO 3361
IF(PARENS.EQ.0)GO TO 1140
LCNT=LCNT+3
IF(MOT.NE.0)CALL ERR(3)
MOT=LCNT-1
1140 DO 11401 JC=1,LCNT-1,3
IF(INP(L).NE.LIST(JC))GO TO 11401
C FINDS DUPLICATE IDENTIFIER
WRITE(JTYPE,11402)INP(L)
11402 FORMAT(' ****** MOTIVIC (',A1,') USED TWICE')
11401 CONTINUE
LIST(LCNT)=INP(L)
PARENS=-1.
INP(L)=IBLA
LIST(LCNT+1)=I
GO TO 236
C ''''''' FOR SINGLE QUOTES
3361 IPRN=IPRN+1
GO TO 236
C JUMPS BACK INTO QUOTE SECTION
C @@@@@@@@@@@@ /@Z/DS3/ ETC.
2361 IF(N.NE.ICOL)GO TO 2362
ICHD=ICHD+1
N=KSLA
GO TO 336
2362 IF(N.NE.IAT)GO TO 5361
CALL MOTIV
GO TO (1773,9004,2722,7773,236),L
5361 IF(N.EQ.IDOL)CALL ERR(8)
C FOUND $ BUT NO @!
INPX=INP(JD+1)
53611 IF(N.NE.ISS)GO TO 53612
IF(INPX.NE.IUU)GO TO 53612
SUB=SUB-200
C FOR SUBROUTINE FLAG. CAN'T CALL SUBR AT SAME TIME AS REP OR X!!!!
GO TO 43615
53612 IF(N.NE.IMM)GO TO 612
IF(INPX.NE.III)GO TO 612
SUB=SUB-200.5
C THE '.5' CALLS 'MICRO' RATHER THAN 'SUBR'.
GO TO 43615
612 IF(N.NE.IAA)GO TO 4361
C FINDS 'ALL'.
IF(INPX.NE.ILL)GO TO 236
ALL=-1.
GO TO 43615
C TYPE 'ALL' AFTER PARAM NUM TO PUT DATA IN ALL INSTS.
4361 IF(N.NE.III)GO TO 43613
IF(ISUB.NE.4)GO TO 43613
C -1= 'NM INV' MAKES INST NAME, P1 AND P2 INVISIBLE (REPLACES SEG, ETC.)
C -2= 'NM IE' MAKES 'END' OF PRINTOUT INVIS. ( ;PRINT(P1)--ETC.)
C -3= BOTH BEGINNING AND END ARE INVIS.
C THIS IS SO PARAMS MAY BE EXTENDED TO 58 ON TO A DUMMY INST.
L=-1
IF(INPX.EQ.IEE)L=L-1
INVIS(INSNUM)=INVIS(INSNUM)+L
43615 DO 43614 L=JD,LEND
N=INP(L)
IF(N.EQ.IBLA)GO TO 236
IF(N.EQ.ISEMI)GO TO 236
43614 INP(L)=IBLA
43613 IF(N.NE.KSLA)GO TO 1336
IF(JD.GE.LEND-1)JZ=0
C SO IT WILL READ NEXT LINE.
GO TO 336
1336 IF(N.NE.ISEMI)GO TO 936
IAMP=-1
336 MLX=JD+1
IF(ISUB.GE.104)GO TO 104
IF(ISUB.GT.3)GO TO 1899
GO TO (101,102,103),ISUB
C PAR MOV LIST OTHERS
936 IF(N.NE.IDOT)GO TO 136
L=INP(JD+1)
DO 836 KL=1,10
836 IF(L.EQ.IDAT(KL))GO TO 236
IF(CODE.EQ.-22..OR.CODE.EQ.-23.)INP(JD)=1
GO TO 236
C CHANGES DOTTED RHYTHMS TO '1'S.
136 IF(N.NE.IQT)GO TO 236
DO 1361 K=JD+1,LEND
IF(INP(K).NE.IQT)GO TO 1361
JD=K+1
GO TO 975
C SKIPS MATERIAL IN QUOTES
1361 CONTINUE
CALL ERR(0)
C OPEN QUOTES
236 JD=JD+1
IF(JD.LE.LEND)GO TO 975
CALL ERR(1)
1899 CALL SCANR
IF(ISUB.LE.0.OR.ISUB.GT.5)GO TO 101
GO TO(1,2,3,4,5),ISUB
101 N=INP(ML)
IZ=ML
ML=ML+1
IF(N.EQ.IBLA)GO TO 101
M=1
JA=-1
C AT THIS POINT IT LOOKS FOR P=PARM, E=END, D=DUPL, C=CONTINUATION, R=RUN.
IF(N.EQ.IPP)GO TO 1
IF(N.EQ.IEE)GO TO 100
CC IF(N.EQ.IEE)GO TO 2308
IF(N.NE.IRR)GO TO 1101
N=INP(ML)
C 'RUN' MAY REPLACE 'END' FOR LAST INST.
IF(N.EQ.IUU)CALL RUNIT
LPAR=1
C TYPE 'RD' (P1) FOR RANDOM DEVIATION, 'RR'(P31) FOR RANDOM RESTS.(NUMP+1)
IF(N.NE.IRR)LPAR=NUMP+1
1205 K=ML
205 K=K+1
IJ=INP(K)
IF(IJ.EQ.IBLA)GO TO 205
IF(IJ.NE.IDOT.AND.IJ.NE.MINUS.AND.
1 IJ.NE.IPP.AND.(IJ.LT.IZERO.OR.IJ.GT.NINE))CALL ERR(0)
C LOOK FOR ILLEGAL FORMAT WITH RR, RD, DF. (ACCEPTS NUM,DOT,Pn,MINUS)
GO TO 201
1101 IF(N.NE.IDD)GO TO 303
IF(INP(ML).NE.IFF)GO TO 7720
C NEXT FOR 'DF' DUTY FACTOR IN PLACE OF A Pn. (TAKE OUT OLD DF STUFF LATER.)
CC ML=ML+1
C 'M' IS USED AFTER 897 INSTEAD OF 'ML'
LPAR=NUMP+2
C USE P32 FOR DF. (IF NUMP=30)
GO TO 1205
303 IF(N.NE.ICC)CALL ERR(0)
C NEXT FOR 'CONTINUATION'. AUTOMATICALLY PUSHES UP PARAM NUMS.
IOFSET=IOFSET+1
LPAR=IOLDPR+IOFSET
WRITE(JTYPE,1201)IOFSET
IF(LPAR.GT.NUMP)CALL ERR(6)
2201 IF(INP(ML).EQ.IBLA)GO TO 3201
C TO MOVE POINTER AHEAD. MUST HAVE BLANK AFTER 'C' OR 'CO' OR 'CONT', ETC.
ML=ML+1
GO TO 2201
3201 IZ=ML-1
M=0
GO TO 201
1201 FORMAT(' ****** REMEMBER ***** PARAMETER OFFSET=',I2)
1 CALL SCANR
IOLDPR=VX1
C SAVE PARAM NUM. FOR POSSIBLE 'CONTINUATION'. BEWARE OF >P30!!!!
LPAR=IOLDPR
IF(LPAR.GT.NUMP)GO TO 201
LPAR=LPAR+IOFSET
IF(LPAR.GT.NUMP)CALL ERR(6)
201 IJ=LPAR
IF(IJ.GT.NUMP+2)CALL ERR(6)
CATCHES PARAM. OUT OF RANGE.
5703 IAMP=0
IF(IJ.LE.NP(INSNUM))GO TO 897
IF(IJ.LE.NUMP)NP(INSNUM)=IJ
897 V(I)=LPAR+INSNUM*10000
C +1=WDCNT, +2=CODE, +3='NM' CCCCC
IJ=I+1
I=I+4
ITMP=0
CODE=0
NFLG=1
ML=IZ+M
C RE=REP R=RHY L=LIT M=MOVE MX=MOVX N=NOTES NU=NUM
C S--L=SUBL S--N=SUBN RL=RLIST RN=RNOTES
5702 ML=ML+1
N=INP(ML)
IF(N.EQ.IBLA)GO TO 5702
IF(N.EQ.ICOMM)GO TO 5702
NL=INP(ML+1)
JA=-1
ISUB=0
IF(N.EQ.IXX)GO TO 2703
IF(N.EQ.IRR)GO TO 6702
IF(N.EQ.IFF)GO TO 8702
IF(N.EQ.IPP)GO TO 7006
IF(N.EQ.IDD)GO TO 3702
IF(N.NE.ICC)GO TO 4005
IF(NL.EQ.IUU)GO TO 7006
C FOR 'CUTOFF'
4005 JA=0
IF(N.EQ.INN)GO TO 6005
IF(N.EQ.IMM)GO TO 703
IF(N.EQ.ILL)GO TO 2720
IF(N.EQ.ISS)GO TO 6703
IF(N.EQ.IQT)GO TO 5720
IF(N.EQ.ISEMI)GO TO 2018
C 7/75 IF(N.EQ.IPP)JA=-1
C FOR ;P5 P3;
7006 CALL SCANR
IF(ISUB.EQ.8)GO TO 8
I=I+JJ
V(IJ+1)=NNUM+SUB
IF(JJ.EQ.1)GO TO 4006
C IF NNUM IS '-2' THEN NOTES ARE PRINTED
IF(NNUM.NE.-2)GO TO 5006
IX=IJ+3
DO 2006 K=2,JJ,3
2006 CALL RANR(VX,K)
C FOR RAN. SELEC. OF NOTES. FINDS HIGHEST NOTE.
5006 IX=IJ+2
DO 6006 K=1,JJ
6006 V(IX+K)=VX(K)
IF(NL.EQ.IUU)GO TO 8006
C JUMP FOR 'CUTOFF'
IF(MOD(JJ,3).NE.0)CALL ERR(12)
V(IX+JJ-2)=1.
C ABOVE ENSURES THAT LAST RAND. UNIT REACHES 100% - 5/74 *********
GO TO 3013
CCCC NOW DONE IN 'SCANR' 7/78 4006 IF(JA)VX1=-VX1/100.-9999.
C CHANGES ;P5 P3; TO ;P5 -9999.03; ***** CHECK OUT ON OTHER MACHINES!
4006 V(I-1)=VX1
GO TO 3013
8006 V(IJ+1)=-19
C FOR 'CUTOFF N1, N2' -- TO END RAND TIMES TOGETHER.
GO TO 3013
6702 IF(NL.EQ.IEE)GO TO 2703
C JUMP IF "REP"
IF(NL.EQ.IRR)GO TO 702
C RR=RAN. RESTS
IF(NL.EQ.IDD)GO TO 1702
C RD=RAN. DEV. OF P1
CODE=-22
IF(NL.EQ.ILL)CODE=-46.0
C JUMP IF "RLIST" (LIST OF RAND SELECTIONS)
IF(NL.NE.INN)GO TO 1016
C JUMP IF NOT "RNOTES"
JA=0
C FOR SCANR
CODE=-36.
GO TO 1016
702 K=NUMP+1
C PARAM CODE FOR RAN. RESTS (NUM. OF PARAMS +1)
GO TO 2702
1702 K=1
C PARAM CODE FOR RAN. DEV.
GO TO 2702
3702 IF(NL.NE.IFF)GO TO 4005
K=NUMP+2
C PARAM CODE FOR DUTY FAC. NUMB. OF PARAMS +2
2702 V(I+1)=V(I-4)
C SHIFT STUFF AROUND
V(I-4)=INSNUM*10000+K
V(I-3)=4.
V(I-2)=-1.
V(I-1)=1.
V(I)=-9999.0-LPAR/100.0
I=I+5
IJ=IJ+5
ML=ML+1
GO TO 5702
6005 CODE=-33
CKL IF(NL.EQ.IAA)GO TO 2721
C NUMS, NOTES, (NAMES. ← NOT ON PDP11)
IF(NL.NE.IUU)GO TO 1016
CODE=-44.
1610 JA=-1
GO TO 1016
8702 CODE=-35
IF(NL.EQ.IUU)GO TO 1016
ML=ML+1
CALL SCANR
7 V(IJ+1)=CODE+SUB
V(IJ+2)=1.
IF(VX1.GT.99)CALL ERR(4)
C TRAPS F NUMS >99.
V(I)=VX1+200.
GO TO 7703
C******** MOVE IS NEXT ***********
703 BW=V(IJ-2)
IC=0
DO 7031 K=ML+1,LEND
LP=INP(K)
IF(LP.EQ.KSLA)GO TO 8031
IF(LP.EQ.IPP)IC=1
C 'MOVP' P7 MOVP/10 3,4.9 5,5.9;MOVES FROM RAN SEL. OF P3,P4 TO P5,P5.
7031 IF(LP.EQ.IXX)IC=-1
C IC=-1 IS FOR MOVX, IC=0 FOR MOVE, IC=1 FOR MOVP.
8031 I=I-1
V(I)=0
X=-9900.-BY
IF(BY.EQ.0)X=-9900.-BG(INSNUM)
IF(BW.EQ.X)GO TO 8005
IF(BW.NE.-9900.-BY)GO TO 1102
V(IJ-2)=X
GO TO 8005
1102 V(IJ)=V(IJ-1)
V(IJ-1)=X
IJ=IJ+1
I=I+1
8005 LP=IJ-1
BW=-9900.-X
ISUB=2
IZ=-1
C ABOVE ARRANGES NECESSARY BG TIME HEADINGS.
4703 GO TO 1299
102 IF(IZ.LT.0)GO TO 2102
C SKIPS NEXT FIRST TIME
BW=V(ICT)+BW
V(I)=-9900.-BW
V(I+1)=V(LP)
V(I+2)=(JJ+2)*ALL
V(I+3)=CODE+SUB
I=I+4
IZ=1
2102 IF(BW.LT.10000.)CALL BGSORT(BW)
C ROUND-OFF NONSENSE
2 VX3=-9900.
VX2=VX3
CALL SCANR
IF(JJ.GT.0)GO TO 5102
JJ=ILIT
C SLASH WILL REPEAT MOVE INPUT -- 6/74
DO 6102 K=1,JJ
6102 VX(K)=VX(K+20)
GO TO 5005
C::::::::::::::: PUT THIS, AND AT 5505, IN SCOR5 ALSO ::::::::::::::
5102 IF(JJ.EQ.4)CALL ERR(9)
C ERROR -- 4 ITEMS IN MOVE IMPOSSIBLE
IF(VX3.NE.-9900.)GO TO 3102
IF(VX2.NE.-9900.)GO TO 4102
VX2=VX1
VX1=10000.
4102 VX3=VX2
JJ=3
C 1,2 OR 3 NUMS CAN BE USED IN NON-RAN MOVES.
3102 IF(IZ.GE.0)GO TO 3006
V(IJ)=(JJ+2)*ALL
C WORD COUNT
CODE=-55.
IF(JJ.NE.3)CODE=-57.
IF(NFLG.LT.0)CODE=CODE-1.
IF(IC.LT.0)CODE=-59.
C CODE=-56 OR -58 FOR NOTES.
V(IJ+1)=CODE+SUB
IZ=0
3006 IF(NFLG.EQ.1)GO TO 5005
CALL RANR(VX,2)
IF(JJ.NE.3)CALL RANR(VX,4)
C FOR RAN. SELEC. OF NOTES. FINDS HIGHEST NOTE.
5005 IF(IC.LE.0)GO TO 3003
C NEXT FOR 'MOVP', MOVE FROM PARAM TO PARAM.
DO 1003 K=2,JJ
1003 VX(K)=-VX(K)/100.0-19999.0
C CHANGES PARAM NUMS TO MAGIC NUMS.
3003 ICT=I
ILIT=JJ
C SAVES FOR SLASH REPEAT FEATURE
IJ=IJ+1
DO 1006 K=1,JJ
VX(20+K)=VX(K)
C SAVES FOR SLASH REPEAT FEATURE
1006 V(IJ+K)=VX(K)
I=I+JJ
IJ=I+2
IF(IAMP.EQ.0)GO TO 1299
C*************** MAY 18,71 ***** ALWAYS RESETS TO TIME 0 WHEN MOVE IS USED.
V(I)=-9900.-BY
GO TO 8703
7703 V(IJ)=4.*ALL
8703 I=I+1
GO TO 4773
C FOR SUBROUTINES, -12=NUMS. -11=LETTERS.
6703 CODE=-12.
IF(INP(ML+3).EQ.ILL)CODE=-11.
V(IJ)=2.*ALL
V(IJ+1)=CODE+SUB
I=I-1
GO TO 4773
C 'REP'
2703 CALL X2703
GO TO 4773
2018 IF(SUB.EQ.0)GO TO 20181
C NEXT FOR Pn SUBR/ I.E. NOTHING BUT P AND SUB CALL. 7/73
V(IJ+1)=-201.
V(IJ+2)=1.
V(IJ+3)=0
GO TO 7703
20181 V(IJ)=3.
V(IJ+1)=-66.
V(IJ+2)=NW+INSNUM*10000
GO TO 4773
C READS /P5 .3 "ABC" .7 "XYZ"/
8 IF(MOD(JJ,2).NE.0)CALL ERR(12)
IF(LPAR.EQ.2)CALL ERR(13)
V(IJ+1)=-77.+SUB
C SUB HAS SUBR CALL INFO
I=I+1
VX(JJ-1)=1
C FOR RAND. SINGLE LITS.
DO 3722 K=1,JJ,2
V(I)=VX(K)
3722 I=I+1
V(IJ+2)=JJ/2
V(IJ+3)=I
DO 4722 K=2,JJ,2
KN=I
I=I+1
L=VX(K)
DO 6722 KL=L,LEND
IF(INP(KL).EQ.IQT)GO TO 4722
IV(I)=INP(KL)
6722 I=I+1
4722 V(KN)=I-KN-1
V(IJ)=(I-IJ)*ALL
GO TO 4773
2720 QTS=0
2721 ISUB=104
IF(NL.EQ.IAA)ISUB=ISUB+1
GO TO 1299
104 IF(ISUB.EQ.104)GO TO 1041
C NEXT FOR INST NAME CHANGES. Pn NAMES/N;
C V LIST= n000n/WDCNT/-89/NUM OF DUPLS/INST NAME/NUM OF LETTERS IN NAME/
C *********** NO 'ALL' OR 'DUPL' FEATURES WITH NAMES **************
V(IJ)=5
V(IJ+1)=-89
CALL SCANR
V(I-1)=VX1
V(I)=RINST(INSNUM)
CXX IV(I+1)=2**(1+(7-LETRS)*7)
I=I+2
GO TO 4773
1041 KL=0
CODE=-88.
DO 6721 K=ML,LEND
L=INP(K)
IF(L.EQ.IBLA)GO TO 6721
JC=K+1
IF(L.EQ.IQT)GO TO 7721
IF(L.EQ.KSLA)GO TO 7232
IF(L.EQ.ISEMI)GO TO 7232
IF(L.NE.IFF)GO TO 1040
IF(INP(K+1).NE.III)GO TO 1040
IF(INP(K+2).NE.INN)GO TO 1040
IF(INP(K+3).NE.IEE)GO TO 1040
C FINDS THE WORD "FINE".
V(I)=-10000.
IF(DUR(INSNUM).LT.0)DUR(INSNUM)=10000
GO TO 1042
1040 IF(L.EQ.IPERC)INP(K)=KSLA
IF(L.EQ.IQUES)INP(K)=ISEMI
IF(L.EQ.IEXPL)INP(K)=ICOMM
IF(L.EQ.ISHRP)INP(K)=ILESS
IF(L.EQ.IANPR)INP(K)=IQT
C THE ABOVE ARE ALL SPECIAL CHAR'S TO AVOID VARIOUS CONFUSIONS.
IF(KL.EQ.0)KL=K
6721 CONTINUE
C FOR REPEAT OF ITEM BY SLASH
C KL IS START OF QUOTE, THEN K IS END -- WHEN NO "S ARE USED.
7232 IF(KL.EQ.0)GO TO 7233
JC=KL
ML=K+1
JD=K-1
NLIT=K-KL
GO TO 8721
7233 DO 7230 KL=ILIT,ILIT+NLIT
V(I)=V(KL)
7230 I=I+1
GO TO 27222
7231 CONTINUE
5720 IAMP=-1
JC=ML+1
C FOR SINGLE 'LIT' ITEMS.
7721 DO 1722 KL=JC+1,LEND
IF(INP(KL).NE.IQT)GO TO 1722
JD=KL-1
ML=KL+1
NLIT=KL-JC
C EXTENT OF LIT ITEM IS FOUND
GO TO 8721
1722 CONTINUE
C CAN'T USE SLASH FOR REPEAT AFTER @Q
8721 V(I)=NLIT
ILIT=I
DO 9721 K=JC,JD
C PUTS ITEM IN "IV" ARRAY
I=I+1
9721 IV(I)=INP(K)
I=I+1
27222 IF(IAMP.EQ.0)GO TO 1299
2722 V(I)=999.
1042 QTS=-1.
CODE=-88.
C 105, -89. FOR LIST OF NAMES FOR INST. NAME CHNGS.
IF(LPAR.EQ.2)CALL ERR(13)
C NO 'LIT' WITH P2!!
V(IJ+1)=CODE+SUB
CXCX V(IJ+1)=X+SUB
V(IJ)=(I-IJ+1)*ALL
IJ=IJ+2
V(IJ)=IJ+1
I=I+1
ISUB=1
GO TO 1299
7720 V(I)=INSNUM
V(I+1)=3.
V(I+2)=-67.
ML=ML+4
CALL SCANR
IF(VX1.EQ.0)VX1=INSNUM-1
C DUPL 0; = DUPL PREV. INST. NUM
V(I+3)=VX1
I=I+4
L=VX1
IF(NP(INSNUM).LT.NP(L))NP(INSNUM)=NP(L)
IF(DUR(INSNUM).LT.0)DUR(INSNUM)=DUR(L)
GO TO 4773
C TYPE 'DUPL N;' N=INST # TO BE DUPLICATED.
C 'PRECEDE' WRITES LINES DIRECTLY ON DSK, BEFORE THE WORD 'PLAY;'.
C NO LIMIT TO THE NUMBER OF LINES. LAST LINE (NOT PRINTED) MUST
C BEGIN WITH *. KNP ARRAY (15) IS EQUIV. TO INP .
6 JPREC=-1
C JPREC IS FLAG TO TELL RUNIT TO READ 'FOR21.DAT'
4341 IF(ITYP.LT.0)GO TO 5341
WRITE(JTYPE,3310)
READ(JTYPE,1301)KNP
CALL SHORT(KNP,K)
WRITE(ID20,1301)(KNP(JD),JD=1,K)
GO TO 6341
7341 CALL ERR(10)
C GO TO ERROR ROUTINE IF MISSING "*".
STOP
5341 READ(ID23,1301,END=7341)KNP
3341 CALL SHORT(KNP,K)
C DON'T TYPE TRAILING BLANKS
IF(MX.EQ.22)GO TO 6341
IF(KTYPE.EQ.0)WRITE(JTYPE,1302)(KNP(JD),JD=1,K)
6341 IF(MX.EQ.22)WRITE(JOUT,1302)(KNP(JD),JD=1,K)
IF(KNP(1).EQ.ISTAR)GO TO 2308
WRITE(ID21)K,(KNP(JD),JD=1,K)
C******** TEMPORARY ****** IF(MX)WRITE(ID21)K,(KNP(JD),JD=1,K)
C WRITES BINARY FILE ON FOR21.DAT
GO TO 4341
1106 KTMP=1
IAMP=0
BW=BY
ITMP=-1
ISUB=5
JA=-1
GO TO 2016
3019 V(I)=990000.00
V(I+1)=4.
V(I+2)=VX1
V(I+3)=VX2
V(I+4)=VX3
I=I+5
BY=BW
IF(VX1.EQ.0)GO TO 2308
BW=BW+VX1
V(I)=-9900.-BW
I=I+1
CALL BGSORT(BW)
9003 IF(IAMP.LT.0)GO TO 4003
2016 VX3=0
VX2=0
GO TO 1299
5 IF(VX2.NE.0)GO TO 105
C 'TEMPO/120;' OR 'TEMPO/1.5 72;' IS OK.
VX2=VX1
VX1=0
105 IF(VX2.GE.12.)VX2=VX2/60.
C TEMPO < 12 = A FACTOR, ≥12 = MM. NUM.
IF(VX3.GE.12.)VX3=VX3/60.
IF(VX3.EQ.0)VX3=VX2
IF(RNAM.EQ.TMPO)GO TO 3019
PCH(1,KTMP)=VX1
PCH(2,KTMP)=VX2
PCH(3,KTMP)=VX3
C PCH(1)=TIME (2)=MM1 (3)=MM2
KTMP=KTMP+1
IF(IAMP.EQ.0)GO TO 2016
4003 VX1=0
IAMP=0
VX2=VX3
IF(RNAM.EQ.TMPO)GO TO 3019
CC PCH(1,KTMP)=0
PCH(1,KTMP)=10000.0
C LAST TEMPO GOES ON FOR EVER
PCH(2,KTMP)=VX2
PCH(3,KTMP)=VX2
C MM CAN BE FROM 11 UP TEMPO FACTOR FROM 10 DOWN.
C UP TO 30 TEMPO CHANGES MAY BE MADE.
1016 IA=I
IZ=1
3100 V(I-2)=CODE+SUB
ISUB=3
5016 IF(IAMP.GE.0)GO TO 1299
117 IF(IZ-2)3013,9004,9004
103 K=INP(ML)
IF(K.EQ.ITT)GO TO 1106
IF(K.EQ.KSLA)GO TO 1014
IF(K.EQ.ISEMI)GO TO 1014
1010 IF(K.NE.IBLA) GO TO 1899
1011 ML=ML+1
GO TO 103
3 IF(VX1.EQ.-99.)GO TO 4022
IF(CODE.EQ.-22.)GO TO 2017
IF(CODE.LT.-23)GO TO 17
IF(IZ/2*2.EQ.IZ)GO TO 17
C CHECKS PAIRS OF NUMBERS FOR 'RTAP'
2017 IF(VX1.LT.-9999.)GO TO 3017
IF(VX1.NE.0)VX1=4./VX1
C RHYTHMIC INPUT OF 0 GIVES 0 DURATION REST!!!
IF(JJ.NE.1)GO TO 2014
3017 V(I)=VX1
GO TO 114
1217 IF(VX1.EQ.-10000.)GO TO 114
C FOR "FINE" IN LIST
V(I+1)=VX2
IF(CODE.EQ.-36.)CALL RANR(V,I)
2217 I=I+1
C SETS UP STRING OF RAND SELECTIONS
GO TO 114
3217 V(I)=V(I-2)
V(I+1)=RB
C FOR SLASH REPTS OF RAND SELEC UNITS. ("REP" CAN'T BE USED!)
GO TO 2217
C******** PUT IN ERROR TRAP FOR "REP" ETC. ******
2014 DO 9006 L=2,JJ
IF(VX(L).EQ.0)GO TO 17
9006 VX1=4./VX(L)+VX1
JJ=1
17 IF(ICHD.EQ.0)GO TO 4014
JJ=1
C SETS UP NEXT NOTE AS CHORD (THIS ONE BECOMES NEG.)
VX1=-VX1
C FOR CHORD FEATURE
ICHD=0
4014 V(I)=VX1
IF(CODE.EQ.-46.)GO TO 1217
IF(CODE.EQ.-36.)GO TO 1217
IF(CODE.NE.-35)GO TO 972
C FINDS F NUM.>15!
C JUMP IF STRING OF RAND SELECS.
972 IF(JJ.EQ.1)GO TO 114
L=VX(JJ)-1
X=V(I)
NL=I+1
I=L+I
DO 1017 K=NL,I
1017 V(K)=X
C ADDS UP TOTAL OF NOTES IN SEQ.
IZ=IZ+L
GO TO 114
1014 IF(CODE.EQ.-46.)GO TO 3217
IF(CODE.EQ.-36.)GO TO 3217
IF(CODE.NE.-33)GO TO 1103
IF(V(I-2).GE.0)GO TO 1103
C NEXT FOR SLASH REPEAT OF CHORD
JC=1
JD=1
GO TO 2103
1103 V(I)=RB
C RB SAVES IT FOR SLASH REPEAT
114 RB=V(I)
I=I+1
IZ=IZ+1
GO TO 5016
4022 JC=VX2+.3
JD=VX3-.5
IF(JJ.EQ.2)JD=1
2103 IZ=IZ+JC*JD
C JD=HOW MANY TIMES, JC=HOW MANY NOTES
IF(CODE.NE.-33)GO TO 3103
8103 N=0
V(IA-1)=0
DO 4103 K=I-1,1,-1
IF(V(K).GE.0)GO TO 7103
IF(V(K).GT.-9999.0)GO TO 4103
C NEG. NUMBS USUALLY ARE CHORD NOTES, -9999.N IS SECONDARY PARAM.
7103 N=N+1
4103 IF(N.EQ.JC)GO TO 5103
5103 IF(V(K-1).GE.0)GO TO 6103
IF(V(K).EQ.0)GO TO 6103
K=K-1
GO TO 5103
6103 JC=I-K
3103 DO 1005 K=1,JD
NL=I+JC-1
DO 2005 L=I,NL
2005 V(L)=V(L-JC)
1005 I=I+JC
RB=V(NL)
C RB SAVES DATA FOR SLASH REPEAT FEATURE.
GO TO 5016
9004 IF(ITMP.EQ.0)GO TO 3013
IZ=IZ-1
KA=1
IC=1
K=0
J=1
Z=0
RC=0
9007 Y=PCH(3,IC)
X=PCH(2,IC)
Z=PCH(1,IC)
CALL SQYY(YY,X,Y,Z)
XT(1)=X
PR=RA
ZZ=Z
CALL ACCEL
IF(K.EQ.IZ)GO TO 3013
IF(RA.NE.-10000.)GO TO 9007
C********* MAY 13,71 OMITS REPEATED RHY. FEATURE.
3013 X=I-IJ
V(IJ+2)=X-3.
V(IJ)=X*ALL
IF(CODE.NE.-35)GO TO 4773
M=IJ+3
C SETS NUMBERS FOR FUNCS.
DO 313 K=M,I-1
X=V(K)
IF(X.LT.-9999.)GO TO 313
CATCHES 'FINE'(-10000), F1-F99 ONLY PLEASE. USE NEG. FOR REST IN FUNC LIST.
C 'R' CAN APPEAR IN FUNC LIST (BUT NOW YOU CAN'T USE F85!!!)
V(K)=X+200.
IF(X.LT.0)V(K)=199.
313 CONTINUE
GO TO 4773
END